;;;Hollerith card editor -*- Mode:LISP; Package:HACKS; Base:8; Readtable:ZL -*-

(OR (BOUNDP 'FONTS:TVFONT) (LOAD "SYS: FONTS; TVFONT QFASL"))
(OR (BOUNDP 'FONTS:TINY) (LOAD "SYS: FONTS; TINY QFASL"))

(DEFVAR CARD-WINDOW)
(DEFCONST CARD-WINDOW-TOP 300)
(DEFCONST CARD-WINDOW-BOTTOM 1200)

(DEFVAR CARD-TOP 140)
(DEFVAR CARD-WIDTH 1400)
(DEFVAR CARD-BOTTOM-HEIGHT 310)
(DEFVAR CARD-TOP-HEIGHT 50)
(DEFVAR CARD-CUT-SIZE 24)
(DEFVAR CARD-MARGIN 30)
(DEFVAR CARD-NUMBER-TOP-HEIGHT 14)
(DEFVAR CARD-NUMBER-HEIGHT 22)
(DEFVAR CARD-LETTER-TOP 2)
(DEFVAR CARD-PUNCH-ARRAY)
(DEFVAR CARD-IMAGE)

;;; Draw the outline
(DEFUN DRAW-CARD (&AUX (WID (1- CARD-WIDTH)) (TOP (+ CARD-TOP CARD-TOP-HEIGHT))
                       (TOT (+ CARD-TOP-HEIGHT CARD-BOTTOM-HEIGHT CARD-TOP)))
  (SYS:%DRAW-RECTANGLE WID CARD-BOTTOM-HEIGHT 0 TOP TV:ALU-ANDCA CARD-WINDOW)
  (SYS:%DRAW-RECTANGLE (- WID CARD-CUT-SIZE) CARD-TOP-HEIGHT CARD-CUT-SIZE CARD-TOP
                       TV:ALU-ANDCA CARD-WINDOW)
  (SYS:%DRAW-TRIANGLE (1- CARD-CUT-SIZE) CARD-TOP (1- CARD-CUT-SIZE) TOP 0 TOP
                      TV:ALU-ANDCA CARD-WINDOW)
  (SYS:%DRAW-LINE (1- CARD-CUT-SIZE) CARD-TOP WID CARD-TOP TV:ALU-IOR T CARD-WINDOW)
  (SYS:%DRAW-LINE WID CARD-TOP WID TOT TV:ALU-IOR T CARD-WINDOW)
  (SYS:%DRAW-LINE WID TOT 0 TOT TV:ALU-IOR T CARD-WINDOW)
  (SYS:%DRAW-LINE 0 TOT 0 TOP TV:ALU-IOR T CARD-WINDOW)
  (SYS:%DRAW-LINE 0 TOP (1- CARD-CUT-SIZE) CARD-TOP TV:ALU-IOR T CARD-WINDOW))

(DEFUN DRAW-LARGE-NUMBERS ()
  (DO ((CHAR #/0 (1+ CHAR))
       (Y (+ CARD-TOP CARD-TOP-HEIGHT CARD-NUMBER-TOP-HEIGHT) (+ Y CARD-NUMBER-HEIGHT)))
      ((> CHAR #/9))
    (DO ((I 1. (1+ I))
         (X (+ CARD-MARGIN 2) (+ X 9)))
        ((> I 80.))
      (SYS:%DRAW-CHAR FONTS:TVFONT CHAR X Y TV:ALU-IOR CARD-WINDOW))))

(DEFUN DRAW-SMALL-NUMBERS (&AUX Y)
  (SETQ Y (+ CARD-TOP CARD-TOP-HEIGHT CARD-NUMBER-TOP-HEIGHT (TRUNCATE CARD-NUMBER-HEIGHT 2)))
  (DRAW-SMALL-NUMBERS-1 Y)
  (SETQ Y (+ Y (* CARD-NUMBER-HEIGHT 9)))
  (DRAW-SMALL-NUMBERS-1 Y))

(DEFUN DRAW-SMALL-NUMBERS-1 (Y)
  (DO ((I 1. (1+ I))
       (X (+ CARD-MARGIN 2) (+ X 9)))
      ((> I 80.))
    (DRAW-SMALL-NUMBER I X Y)))

(DEFUN DRAW-SMALL-NUMBER (I X Y)
    (IF (< I 10.)
        (SYS:%DRAW-CHAR FONTS:TINY (+ I #/0) (1+ X) Y TV:ALU-IOR CARD-WINDOW)
        (SYS:%DRAW-CHAR FONTS:TINY (+ (TRUNCATE I 10.) #/0) (1- X) Y TV:ALU-IOR CARD-WINDOW)
        (SYS:%DRAW-CHAR FONTS:TINY (+ (\ I 10.) #/0) (+ X 3) Y
                        TV:ALU-IOR CARD-WINDOW)))

(DEFUN DRAW-LOGO (&AUX X Y)
  (SETQ X (+ CARD-MARGIN 2 (* 9 6))
        Y (+ CARD-TOP CARD-TOP-HEIGHT CARD-NUMBER-TOP-HEIGHT (* CARD-NUMBER-HEIGHT 10.)))
  (DRAW-TINY "IBM" X Y)
  (SETQ X (+ X (* 9 2)))
  (LET ((X0 (1- X)) (Y0 (1- Y))
        (X1 (+ X 15.)) (Y1 (+ Y 7)))
    (SYS:%DRAW-LINE X0 Y0 X1 Y0 TV:ALU-IOR T CARD-WINDOW)
    (SYS:%DRAW-LINE X1 Y0 X1 Y1 TV:ALU-IOR T CARD-WINDOW)
    (SYS:%DRAW-LINE X1 Y1 X0 Y1 TV:ALU-IOR T CARD-WINDOW)
    (SYS:%DRAW-LINE X0 Y1 X0 Y0 TV:ALU-IOR T CARD-WINDOW))
  (DRAW-TINY "5081" X Y))

(DEFUN DRAW-TINY (STR X Y)
  (DO ((I 0 (1+ I))
       (LEN (ARRAY-ACTIVE-LENGTH STR))
       (X X (+ X 4)))
      (( I LEN))
    (SYS:%DRAW-CHAR FONTS:TINY (AREF STR I) X Y TV:ALU-IOR CARD-WINDOW)))

(DEFUN DRAW-IT ()
  (TV:PREPARE-SHEET (CARD-WINDOW)
    (DRAW-CARD)
    (DRAW-LARGE-NUMBERS)
    (DRAW-SMALL-NUMBERS)
    (DRAW-LOGO)))

(DEFUN DRAW-CARD-CHAR (CHAR CHAR-X &AUX X BITS)
  (TV:PREPARE-SHEET (CARD-WINDOW)
    (SETQ X (+ CARD-MARGIN 2 (* CHAR-X 9)))
    (SYS:%DRAW-CHAR FONTS:TVFONT CHAR X
                    (+ CARD-TOP CARD-LETTER-TOP) TV:ALU-IOR CARD-WINDOW)
    (AND (= (SETQ BITS (AREF CARD-PUNCH-ARRAY CHAR)) 177777)
         (FERROR NIL "Attempt to punch ~C" CHAR))
    (DO ((BITS BITS (LSH BITS -1))
         (Y (+ CARD-TOP CARD-TOP-HEIGHT CARD-NUMBER-TOP-HEIGHT (* CARD-NUMBER-HEIGHT 9))
            (- Y CARD-NUMBER-HEIGHT)))
        ((ZEROP BITS))
      (AND (BIT-TEST 1 BITS)
           (SYS:%DRAW-RECTANGLE 6 (- CARD-NUMBER-HEIGHT 3) X Y
                                TV:ALU-IOR CARD-WINDOW)))))

(DEFUN ERASE-CARD-CHAR (CHAR CHAR-X &AUX X BITS)
  (TV:PREPARE-SHEET (CARD-WINDOW)
    (SETQ X (+ CARD-MARGIN 2 (* CHAR-X 9)))
    (SYS:%DRAW-RECTANGLE 5 10. X (+ CARD-TOP CARD-LETTER-TOP)
                         TV:ALU-ANDCA CARD-WINDOW)
    (AND (= (SETQ BITS (AREF CARD-PUNCH-ARRAY CHAR)) 177777)
         (FERROR NIL "Attempt to unpunch ~C" CHAR))
    (DO ((BITS BITS (LSH BITS -1))
         (Y (+ CARD-TOP CARD-TOP-HEIGHT CARD-NUMBER-TOP-HEIGHT (* CARD-NUMBER-HEIGHT 9))
            (- Y CARD-NUMBER-HEIGHT))
         (I 9 (1- I)))
        ((ZEROP BITS))
      (COND ((BIT-TEST 1 BITS)
             (SYS:%DRAW-RECTANGLE 6 (- CARD-NUMBER-HEIGHT 3) X Y
                                  TV:ALU-ANDCA CARD-WINDOW)
             (COND (( I 0)
                    (SYS:%DRAW-CHAR FONTS:TVFONT (+ #/0 I) X Y TV:ALU-IOR CARD-WINDOW)
                    (AND (OR (= I 0) (= I 9))
                         (DRAW-SMALL-NUMBER (1+ CHAR-X) X
                                            (+ Y (TRUNCATE CARD-NUMBER-HEIGHT 2)))))))))))

(DEFVAR CARD-PUNCH-FORMAT
        '((#\SP . ())
          (#/. . (12. 8 3))
          (#/) . (12. 8 4))
          (#/] . (12. 8 5))
          (#/< . (12. 8 6))
          (#/_ . (12. 8 7))
          (#/+ . (12.))
          (#/! . (11. 8 2))
          (#/$ . (11. 8 3))
          (#/* . (11. 8 4))
          (#/[ . (11. 8 5))
          (#/> . (11. 8 6))
          (#/& . (11. 8 7))
          (#/- . (11.))
          (#// . (0 1))
          (#/' . (0 8 3))
          (#/( . (0 8 4))
          (#/" . (0 8 5))
          (#/# . (0 8 6))
          (#/% . (0 8 7))
          (#/= . (8 3))
          (#/@ . (8 4))
          (#/^ . (8 5))
          (#/, . (8 6))
          (#/\ . (8 7))
          (#/A . (12. 1))
          (#/B . (12. 2))
          (#/C . (12. 3))
          (#/D . (12. 4))
          (#/E . (12. 5))
          (#/F . (12. 6))
          (#/G . (12. 7))
          (#/H . (12. 8))
          (#/I . (12. 9))
          (#/J . (11. 1))
          (#/K . (11. 2))
          (#/L . (11. 3))
          (#/M . (11. 4))
          (#/N . (11. 5))
          (#/O . (11. 6))
          (#/P . (11. 7))
          (#/Q . (11. 8))
          (#/R . (11. 9))
          (#/; . (0 8 2))
          (#/S . (0 2))
          (#/T . (0 3))
          (#/U . (0 4))
          (#/V . (0 5))
          (#/W . (0 6))
          (#/X . (0 7))
          (#/Y . (0 8))
          (#/Z . (0 9))
          (#/0 . (0))
          (#/1 . (1))
          (#/2 . (2))
          (#/3 . (3))
          (#/4 . (4))
          (#/5 . (5))
          (#/6 . (6))
          (#/7 . (7))
          (#/8 . (8))
          (#/9 . (9))))

(DEFUN INITIALIZE-CARD-PUNCH-ARRAY ()
  (OR (BOUNDP 'CARD-PUNCH-ARRAY)
      (SETQ CARD-PUNCH-ARRAY (MAKE-ARRAY 200 ':TYPE 'ART-16B)))
  (FILLARRAY CARD-PUNCH-ARRAY '(-1))
  (DOLIST (LIST CARD-PUNCH-FORMAT)
    (ASET (DO ((PUNCHES (CDR LIST) (CDR PUNCHES))
               (PUNCH)
               (VALUE 0))
              ((NULL PUNCHES) VALUE)
            (SETQ PUNCH (CAR PUNCHES))
            (AND (< PUNCH 10.) (SETQ PUNCH (- 10. PUNCH)))
            (SETQ VALUE (LOGIOR VALUE (LSH 1 (1- PUNCH)))))
          CARD-PUNCH-ARRAY (CAR LIST))))

(OR (BOUNDP 'CARD-PUNCH-ARRAY) (INITIALIZE-CARD-PUNCH-ARRAY))

;;; Now the top level editor
(DEFUN CARD-EDITOR ()
  (SETUP-CARD-WINDOW)
  (TV:WINDOW-CALL (CARD-WINDOW :DEACTIVATE)
    (SEND CARD-WINDOW :CLEAR-WINDOW)
    (CARD-EDITOR-INTERNAL)))

(DEFUN SETUP-CARD-WINDOW ()
  (OR (BOUNDP 'CARD-WINDOW)
      (SETQ CARD-WINDOW (MAKE-INSTANCE 'TV:WINDOW
                                       :LABEL NIL
                                       :SUPERIOR TV:MOUSE-SHEET
                                       :TOP CARD-WINDOW-TOP
                                       :BOTTOM CARD-WINDOW-BOTTOM))))

(DEFUN CARD-EDITOR-INTERNAL ()
  (OR (BOUNDP 'CARD-IMAGE)
      (SETQ CARD-IMAGE (MAKE-ARRAY 80.
                                   ':TYPE 'ART-STRING
                                   ':LEADER-LENGTH 1)))
  (STORE-ARRAY-LEADER 0 CARD-IMAGE 0)
  (DRAW-IT)
  (*CATCH 'RETURN-FROM-EDITOR
    (DO () (NIL)
      (*CATCH 'ABORT-COMMAND
        (PROG (CH)
          (TV:SHEET-SET-CURSORPOS CARD-WINDOW
                                  (+ CARD-MARGIN 2 (* (ARRAY-LEADER CARD-IMAGE 0) 9))
                                  (+ CARD-TOP CARD-LETTER-TOP))
          (SETQ CH (CHAR-UPCASE (FUNCALL CARD-WINDOW ':TYI)))
          (SELECTQ CH
            (#\CR
             (*THROW 'RETURN-FROM-EDITOR T))
            (#\RUBOUT
             (LET ((I (1- (ARRAY-LEADER CARD-IMAGE 0))))
               (COND ((MINUSP I)
                      (BEEP)
                      (*THROW 'ABORT-COMMAND T)))
               (ERASE-CARD-CHAR (AREF CARD-IMAGE I) I)
               (STORE-ARRAY-LEADER I CARD-IMAGE 0)))
            (#\CLEAR
             (DO ((I (1- (ARRAY-LEADER CARD-IMAGE 0)) (1- I)))
                 ((MINUSP I))
               (ERASE-CARD-CHAR (AREF CARD-IMAGE I) I))
             (STORE-ARRAY-LEADER 0 CARD-IMAGE 0))
            (OTHERWISE
             (COND ((OR ( CH 200)
                        (= (AREF CARD-PUNCH-ARRAY CH) 177777)
                        (NOT (ARRAY-PUSH CARD-IMAGE CH)))
                    (BEEP)
                    (*THROW 'ABORT-COMMAND T)))
             (DRAW-CARD-CHAR CH (1- (ARRAY-LEADER CARD-IMAGE 0)))))))))
  (TV:SHEET-SET-CURSORPOS CARD-WINDOW 0
                          (+ CARD-TOP-HEIGHT CARD-BOTTOM-HEIGHT CARD-TOP))
  CARD-IMAGE)

(DEFDEMO "Hollerith Editor" "Upward compatibilty with primitive computers." (CARD-EDITOR))
(DEFDEMO "Multiple Hollerith Editor"
         "Upward compatibilty with primitive computers."
  (EDIT-MULTIPLE-CARDS))

(DEFCONST CARD-Y-OFFSET -20)
(DEFCONST CARD-X-OFFSET -5)
(DEFUN EDIT-MULTIPLE-CARDS ()
  (SETUP-CARD-WINDOW)
  (TV:WINDOW-CALL (CARD-WINDOW :DEACTIVATE)
    (SEND CARD-WINDOW :CLEAR-WINDOW)
    (DO () (())
      (CARD-EDITOR-INTERNAL)
      (LET ((X-WID (- (TV:SHEET-INSIDE-WIDTH CARD-WINDOW) (ABS CARD-X-OFFSET)))
            (Y-WID (- (TV:SHEET-INSIDE-HEIGHT CARD-WINDOW) (ABS CARD-Y-OFFSET))))
        (SEND CARD-WINDOW
              :BITBLT-WITHIN-SHEET TV:ALU-SETA
                                   (IF (< CARD-X-OFFSET 0) X-WID (- X-WID))
                                   (IF (< CARD-Y-OFFSET 0) Y-WID (- Y-WID))
                                   (IF (< CARD-X-OFFSET 0) (- CARD-X-OFFSET) 0)
                                   (IF (< CARD-Y-OFFSET 0) (- CARD-Y-OFFSET) 0)
                                   (IF (< CARD-X-OFFSET 0) 0 CARD-X-OFFSET)
                                   (IF (< CARD-Y-OFFSET 0) 0 CARD-Y-OFFSET))
        (SEND CARD-WINDOW :DRAW-RECTANGLE
                          (ABS CARD-X-OFFSET) (TV:SHEET-INSIDE-HEIGHT CARD-WINDOW)
                          (IF (< CARD-X-OFFSET 0)
                              (+ (TV:SHEET-INSIDE-WIDTH CARD-WINDOW) CARD-X-OFFSET)
                            0)
                          0
                          TV:ALU-ANDCA)
        (SEND CARD-WINDOW :DRAW-RECTANGLE
                          (TV:SHEET-INSIDE-WIDTH CARD-WINDOW) (ABS CARD-Y-OFFSET)
                          0
                          (IF (< CARD-Y-OFFSET 0)
                              (+ (TV:SHEET-INSIDE-WIDTH CARD-WINDOW) CARD-Y-OFFSET)
                            0)
                          TV:ALU-ANDCA)))))
